home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / rexx / imc / rexx-imc.5 / calc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-06-25  |  47.1 KB  |  1,148 lines
  1. /* The calculating routines of REXX/imc         (C) Ian Collier 1992 */
  2.  
  3. #include"functions.h"
  4. #include"globals.h"
  5. #include<memory.h>
  6. #include<string.h>
  7. #include<malloc.h>
  8.  
  9. /* scanning() is the expression evaluator, called 30 times from various parts
  10.    of the interpreter to collect an expression from a program line.  The
  11.    program line is given as the "line" parameter, and the character pointer
  12.    as "ptr".  An expression will be evaluated and placed on the calculator
  13.    stack.  In addition its address on the stack will be returned and its
  14.    length will be placed in len.  On exit, ptr will point to the character
  15.    immediately following the expression (it will not point to a space). */
  16. char *scanning(line,ptr,len)
  17. char *line;
  18. int *ptr,*len;
  19. {
  20. /* the following identifiers are arranged in order as defined by the
  21.    constants OPpower, OPmul, ... , OPggeq.  binops contains the character
  22.    codes of all the binary operators, and binpri contains their priorities. */
  23.       
  24.    static char binops[]={POWER,'*','/','+','-',' ',CONCAT,'=',EQU,'<',LEQ,'>',GEQ,NEQ,'&',LXOR,'|','%',MOD,NNEQ,LESS,GRTR,LLEQ, GGEQ};
  25.    static char binpri[]={  10,  8,  8,  7,  7,  6,  6,     5,  5,  5,  5,  5,  5,  5,  3,  2,   2,  8,  8,  5   ,5   ,5    ,5    ,5};
  26.    void binplus();
  27.    void binmin();
  28.    void binmul();
  29.    void bindiv();
  30.    void bincat();
  31.    void binexp();
  32.    void binbool();
  33.    void binrel();
  34.    void unnot();
  35.    void unmin();
  36.    void unplus();
  37.    static void (*binprg[])() ={binexp, /* This array contains the addresses */
  38.                                binmul, /* of all the functions which are    */
  39.                                bindiv, /* called to implement the various   */
  40.                                binplus,/* operators, in the order such that */
  41.                                binmin, /* binprg(OPxyz) is the routine to   */
  42.                                bincat, /* implement the xyz operator        */
  43.                                bincat,
  44.                                binrel,
  45.                                binrel,
  46.                                binrel,
  47.                                binrel,
  48.                                binrel,
  49.                                binrel,
  50.                                binrel,
  51.                                binbool,
  52.                                binbool,
  53.                                binbool,
  54.                                bindiv,
  55.                                bindiv,
  56.                                binrel,
  57.                                binrel,
  58.                                binrel,
  59.                                binrel,
  60.                                binrel,
  61.                                unmin,
  62.                                unplus,
  63.                                unnot};
  64.    struct {char op;char pri;} opstack[maxopstack]; /* an operation stack */
  65.    int opptr=1;              /* the operation stack pointer */
  66.    int lp;
  67.    char *exp;
  68.    int expn;
  69.    int explen;
  70.    int t;
  71.    int n;
  72.    int dot;
  73.    int endnum;
  74.    char quote;
  75.    char varname[maxvarname];
  76.    char *vg;
  77.    char op,pri;
  78.    char ch,c1;
  79.    int intermed=trcflag&Tintermed; /* whether to trace intermediate results */
  80.    static char what[4]=">>>";      /* the trace prefix to use */
  81.    
  82.    opstack[0].pri=0;               /* The bottom of stack marker */
  83.    trcresult++; /* count levels - trace result only on outer level */
  84.    while(1){ /* loop until expression has finished */
  85.       lp=1;
  86.       while(lp){ /* loop until a value has been stacked */
  87.          if(opptr>=maxopstack-1)die(Eopstk);
  88.          switch(line[*ptr]){
  89.             case '(':(*ptr)++, /* parenthesised expressions are stacked by */
  90.                scanning(line,ptr,&explen); /* calling scanning recursively */
  91.                if(line[(*ptr)++]!=')')die(Elpar);  /* it must end with ')' */
  92.                lp=0;
  93.            what[1]=0;      /* Prevent the value from being traced, since */
  94.                break;          /* scanning() already traced it               */
  95.             case '+':(*ptr)++,/* for unary '+' stack code OPplus, priority 11 */
  96.                opstack[opptr].op=OPplus,
  97.                opstack[opptr++].pri=11;
  98.                break;
  99.             case '-':(*ptr)++, /* for unary '-' stack code OPneg, priority 11 */
  100.                opstack[opptr].op=OPneg,
  101.                opstack[opptr++].pri=11;
  102.                break;
  103.             case '\\':(*ptr)++,      /* for '\' stack code OPnot, priority 11 */
  104.                opstack[opptr].op=OPnot,
  105.                opstack[opptr++].pri=11;
  106.                break;
  107.             case '\'':             /* Quoted expression... */
  108.             case '\"':quote=line[(*ptr)++],
  109.                expn= *ptr;
  110.                while(line[expn++]!=quote||line[expn]==quote)
  111.                   if(line[expn-1]==quote)expn++; /* search for close quote */
  112.                if(line[expn]=='X'&&!rexxsymboldot(line[expn+1]))
  113.               stackx(line+*ptr,expn-*ptr-1),expn++;/* stack hex */
  114.                else if(line[expn]=='B'&&!rexxsymboldot(line[expn+1]))
  115.               stackb(line+*ptr,expn-*ptr-1),expn++;/* stack bin */
  116.            else stackq(line+*ptr,expn-*ptr-1,quote); /* stack string */
  117.                    /* A string constant has been found, but if
  118.                   it is followed by '(' it is a function call which
  119.               bypasses the internal label search. */
  120.                if(line[expn]=='('){
  121.                   (*ptr)=expn+1;
  122.                   exp=delete(&n);
  123.                   if(n>maxvarname-1)die(Elong); /* the function name is */
  124.                   memcpy(varname,exp,n);        /* stored in varname    */
  125.                   t=1;
  126.                   goto rxfncall;
  127.                }
  128.                (*ptr)=expn;          /* step past string constant in line. */
  129.                lp=0;                 /* signal "stacked a value" */
  130.                what[1]='L';
  131.                break;
  132.             default:                 /* stack a variable or literal or
  133.                                         call a function. */
  134.                if(line[*ptr]<0)die(Ebadexpr);
  135.                if(!(t=rexxsymbol(line[*ptr]))&&line[*ptr]!='.')die(Ebadexpr);
  136.                what[1]='L';
  137.                if(t!=1){             /* a constant symbol. Special processing
  138.                           is required to ensure that if the symbol is a
  139.                   number in exponential format then any "+" or "-"
  140.                   in the number is treated as part of it */
  141.                   n=1;dot=0;  /* dot is the count of dots in the number; n is
  142.                       a flag meaning: 0 an ordinary constant symbol,
  143.                   1 an exponent is allowed, 2 this is the
  144.                   character after "E". */
  145.                   endnum=0;   /* The position of any "+" or "-" in case the
  146.                       exponent is badly formed (e.g. in 1e+23.4) */
  147.                   for(expn= *ptr;;expn++){
  148.              c1=line[expn];
  149.                      if(!n) /* stop whenever a non-symbol character is found */
  150.                 if(!rexxsymboldot(c1)){ /* But remove a "+" or "-" if
  151.                                     the exponent was empty */
  152.                if(endnum&&endnum+1==expn)expn=endnum; 
  153.                break;
  154.             }
  155.             else if(endnum&&(c1<'0'||c1>'9'))
  156.                {expn=endnum;break;} /* Remove a non-numeric */
  157.             else;                   /* exponent following a sign */
  158.                      else {
  159.                         if(alphanum(c1)<2){  /* not number or dot */
  160.                            if(n==2&&(c1=='-'||c1=='+')){
  161.                               n=0; /* OK to have + or - after an E */
  162.                   endnum=expn; 
  163.                               continue;
  164.                            }
  165.                            if(n==1&&c1=='E')
  166.                   {n=2;continue;}/* Expect an optional sign next */
  167.                            n=0;              /* it's not a number any more */
  168.                            if(!rexxsymboldot(c1))
  169.                   break;         /* allow only symbol characters */
  170.                         }
  171.                         if(n==2)n=0;         /* No sign after the 'E' */
  172.                         else if(c1=='.'&&dot++>0)n=0; /* a second dot found */
  173.                      }
  174.                   }
  175.                   if(expn==*ptr)die(Ebadexpr); /* The symbol has zero length */
  176.                   stack(line+*ptr,expn-*ptr),  /* Stack the constant symbol */
  177.                   (*ptr)=expn;                 /* step past it. */
  178.                }else{ /* A symbol follows.  If a '(' follows the symbol, then
  179.                      it is a function call */
  180.                   n=0,t=0;           /* t=0 -> search internal definitions */
  181.                   for(expn= *ptr;rexxsymboldot(varname[n++]=line[expn++]);)
  182.                      if(n>=maxvarname-1)die(Elong);
  183.              /* the symbol has been copied to varname */
  184.                   if(--n>0&&varname[n-1]!='.'&&varname[n]=='('){
  185.                   *ptr=expn;   /* Step past the symbol */
  186. /* A function call has now been found. varname holds its name, and n holds
  187.    its length.  t!=0 if the name was in quotes, t=0 otherwise. */
  188.       rxfncall:      varname[n]=0; /* The name is nul-terminated (it cannot */
  189.                      n=0;          /* contain a nul character) */
  190.                      if(line[*ptr]!=')') /* Unless no arguments given... */
  191.                      while(1){           /* get each one by calling scanning */
  192.                         if((ch=line[*ptr])==','||ch==')')stacknull();
  193.                         else scanning(line,ptr,&explen);
  194.                         n++;
  195.                         if((ch=line[*ptr])==',')++*ptr;
  196.                         else if(ch!=')')die(Elpar);
  197.                         else break;
  198.                      }
  199.                      ++*ptr; /* Step past the ')'.  n contains the arg count.*/
  200.                      if(!rxcall(0,varname,n,t,"FUNCTION"))  /* This is where */
  201.                 die(Enoresult);          /* the function gets called */
  202.                      lp=0;
  203.                      what[1]='F';
  204.                      break;
  205.                   }
  206.                   /* else ignore the result of the search for a function name
  207.           and try to get a variable instead */
  208.                   getvarname(line,ptr,varname,&explen,maxvarname),
  209.                   vg=varget(varname,explen,&expn);
  210.                   if(vg==cnull){ /* See if novalue errors are caught */
  211.              if((varname[0]&128)&&!memchr(varname,'.',explen))
  212.                 varname[explen++]='.';/* Add a dot to undefined stem */
  213.                      varname[0]&=127;     /* if OK stack the variable's name */
  214.              varname[explen]=0;
  215.                      if(sgstack[interplev].bits&(1<<Inovalue))
  216.                         errordata=varname,
  217.                         die(Enovalue);
  218.                      stack(varname,explen);
  219.                   }
  220.                   else what[1]='V',stack(vg,expn); /* it was found */
  221.                }
  222.                lp=0;
  223.          }
  224.       }
  225.       if(intermed&&what[1])tracelast(what);
  226.       /* at this point a (possibly null) list of operators and their priorities
  227.          have been stacked, and a value has just been placed on the calculator
  228.          stack. The next character will either be a terminator or an (explicit
  229.          or implicit) binary operator.  Special case: if it is a unary
  230.      operator (i.e. "logical not"), then it is a syntax error. */
  231.       ch=line[*ptr];
  232.       if(ch=='\\')die(Ebadexpr);
  233.       if((c1=line[*ptr])==-1||!c1||c1==')'||c1==','||c1<SYMBOL)pri=0;
  234.          /* terminators are ';', 'EOL', ')', ',' and all `words'.  Priority 0
  235.      signals that a terminator was found. */
  236.       else{
  237.          (*ptr)++;                                        /* Go past the op */
  238.          for(op=0;binops[op]!=ch&&op<24;op++);      /* "op" holds its index */
  239.          if(op<24)pri=binpri[op];               /* "pri" holds its priority */
  240.          else (*ptr)--, /* The char is not a binary operator, so it must be */
  241.               op=OPcat, /* an implicit concatenation, priority 6. */
  242.               pri=6;
  243.       }
  244.       /* Having found the next operator and its priority (priority 16 highest,
  245.         0 meaning no further operators), we now examine previous operations
  246.         to see whether they should be done now. If not, another value is
  247.         stacked unless the priorities of both the current operator and the
  248.         top stacked operator are zero, in which case evaluation has finished.*/
  249.       while(opstack[opptr-1].pri>=pri&&opstack[opptr-1].pri){
  250.          opptr--,
  251.          eworkptr=0,
  252.          binprg[opstack[opptr].op](opstack[opptr].op); /* This does the op */
  253.          if(intermed)
  254.             what[1]=(opstack[opptr].op>23?'P':'O'), /* Trace the op's result */
  255.             tracelast(what);
  256.       }
  257.       if(!pri)break;
  258.       opstack[opptr].op=op,     /* The binary operator just encountered is */
  259.       opstack[opptr++].pri=pri; /* stacked before finding the next value.  */
  260.    } /* Evaluation has finished, so the top stack value is returned. */
  261.    (*len)= *((int *)(cstackptr+ecstackptr)-1);
  262.    if(!--trcresult &&(trcflag&Tresults))               /* trace the result */
  263.       tracelast(">>>");
  264.    if(!trcresult)timeflag&= (~2); /* clear timestamp after a result */
  265.    return cstackptr+ecstackptr-align(*len)-four;
  266. }
  267.  
  268. void tracelast(type) /* trace the last value on the stack */
  269. char *type;          /* The trace prefix to use */
  270. {
  271.    char *exp=cstackptr+ecstackptr-four;
  272.    int len= *(int *)exp;
  273.    exp -=align(len);
  274.    traceline(type,exp,len);
  275. }
  276.    
  277. void traceline(type,exp,len) /* trace a result or other string */
  278. char *type;      /* the trace prefix to use */
  279. char *exp;       /* the string to be traced */
  280. int len;         /* the length of the string */
  281. {
  282.    int i;
  283.    char c;
  284.    fprintf(traceout,"      %s   ",type);
  285.    for(i=0;i<traceindent*pstacklev;i++)putc(' ',traceout);
  286.    putc('\"',traceout);
  287.    for(i=0;i<len;i++)putc((c=exp[i]&127)<' '||c==127? '?':c,traceout);
  288.    fputs("\"\n",traceout);
  289. }
  290.  
  291. void stack(exp,len)  /* stack a copy of exp whose length is explen */
  292. char *exp;
  293. int len;
  294. {
  295.    int alen=align(len);
  296.    mtest(cstackptr,cstacklen,ecstackptr+alen+2*four,len+256);
  297.    memcpy(cstackptr+ecstackptr,exp,len), /* The string goes on first */
  298.    ecstackptr+=alen,                     /* it is padded into alignment */
  299.    (*(int *)(cstackptr+ecstackptr))=len, /* The length is then appended. */
  300.    ecstackptr+=four;
  301. }
  302.  
  303. void stackq(exp,len,quote)  /* stack a copy of exp whose length is explen, */
  304. char *exp;                  /* reducing double quotes to single quotes */
  305. int len;
  306. char quote;  /* The type of quote mark to reduce from double to single */
  307. {            /* It is guaranteed that this always occurs in pairs */
  308.    int i=0,l=0;
  309.    char *p;
  310.    char c;
  311.    mtest(cstackptr,cstacklen,ecstackptr+len+3*four,len+256);
  312.    for(p=cstackptr+ecstackptr;i<len;i++){ /* Copy the string */
  313.      p[l]=c=exp[i],
  314.      l++;
  315.      if(c==quote)i++;    /* Omit the next character after a quote. */
  316.    }
  317.    ecstackptr+=align(l), /* Pad the string */
  318.    (*(int *)(cstackptr+ecstackptr))=l, /* and append the length. */
  319.    ecstackptr+=four;
  320. }
  321.  
  322. void stackx(exp,len)  /* Interpret exp (whose length is len) as a hex
  323.                          constant and stack it */
  324. char *exp;
  325. int len;
  326. {
  327.    int l=0,o;
  328.    unsigned char m,n;
  329.    char d;
  330.    mtest(cstackptr,cstacklen,ecstackptr+len/2+3*four,len/2+256);
  331. /* while(exp[0]==' '&&len)exp++,len--; */ /* leading spaces OK if uncommented*/
  332.    if(len&&(exp[0]==' '||exp[0]=='\t'))die(Ehex);  /* leading spaces not OK */
  333.    for(o=0;o<len&&exp[o]!=' '&&exp[o]!='\t';o++);/* Find length of first chunk */
  334.    (o%2)?(o=1):(o=2); /* If odd, the first hex byte has 1 digit, otherwise 2 */
  335.    while(len){
  336.       while((exp[0]==' '||exp[0]=='\t')&&len)exp++,len--;  /* Skip spaces */
  337. /*    if(len==0)break;  */         /* OK for trailing blanks if uncommented */
  338.       if(len<o)die(Ehex);          /* Error if less than a whole byte exists */
  339.       for(m=(n=0);m<o;m++){        /* for one byte... */
  340.          d=(*(exp++))-'0',         /* convert a digit to hex */
  341.          len--;
  342.          if(d<0)die(Ehex);
  343.          if(d>9)if((d-=7)<10)die(Ehex);
  344.          if(d>15)if((d-=32)<10)die(Ehex);
  345.          if(d>15)die(Ehex);
  346.          n=n*16+d;                 /* and accumulate */
  347.       }
  348.       o=2,                         /* Each byte except the first has 2 digits*/
  349.       cstackptr[ecstackptr++]=n,   /* Stack each byte */
  350.       l++;
  351.    }
  352.    ecstackptr+=toalign(l),         /* pad the string */
  353.    (*(int *)(cstackptr+ecstackptr))=l, /* and append the length. */
  354.    ecstackptr+=four;
  355. }
  356. void stackb(exp,len)  /* Interpret exp as a binary constant and stack it */
  357. char *exp;
  358. int len;
  359. {
  360.    int l;
  361.    int al=align(len/8+1); /* maximum amount of space needed */
  362.    unsigned char c=0,n,b,d;
  363.    mtest(cstackptr,cstacklen,ecstackptr+al+2*four,al+256);
  364.    if(len&&exp[0]==' ')die(Ebin);   /* leading spaces not OK */
  365.    for(l=b=0;l<len;l++)b+=(exp[l]!=' '&&exp[l]!='\t'); /* find number of digits (nonblanks)*/
  366.    l=0;
  367.    n=(((b-1)%8)>=4)+1;              /* number of nybbles in first byte */
  368.    b=(b-1)%4+1;                     /* number of bits in first nybble */
  369.    while(len){
  370.       while((exp[0]==' '||exp[0]=='\t')&&len)exp++,len--;  /* Skip spaces */
  371.       if(len<b)die(Ehex);           /* Error if less than one nybble exists */
  372.       while(b--){                   /* for each bit of the nybble... */
  373.          d=exp++[0]-'0';
  374.      if(d>1)die(Ebin);
  375.      c=(c<<1)|d;                /* add to the current character */
  376.      len--;
  377.       }
  378.       b=4;                          /* next nybble has 4 bits */
  379.       if(!--n){                     /* a byte was completed */
  380.          cstackptr[ecstackptr++]=c, /* Stack each byte */
  381.      l++;
  382.      n=2;                       /* next byte has 2 nybbles */
  383.       }
  384.    }
  385.    if(n!=2)die(Ebin);               /* half a byte was encountered */
  386.    ecstackptr+=toalign(l),          /* pad the string */
  387.    (*(int *)(cstackptr+ecstackptr))=l, /* and append the length. */
  388.    ecstackptr+=four;
  389. }
  390. void stackint(i) /* stack an integer i */
  391. int i;
  392. {
  393.    char num[20];
  394.    sprintf(num,"%d",i);
  395.    stack(num,strlen(num));
  396. }
  397.  
  398. void stacknull() /* Stack a null - i.e. a value with length -1 */
  399. {
  400.    mtest(cstackptr,cstacklen,ecstackptr+2*four,256);
  401.    (*(int *)(cstackptr+ecstackptr))= -1,
  402.    ecstackptr+=four;
  403. }
  404.  
  405. /* The various binary and unary operators follow.  Each one operates on the
  406.    top 1 or 2 values on the calculator stack, deletes them, and stacks a
  407.    result.  The single parameter to each routine is the operator number
  408.    (e.g. OPplus), which serves to distinguish between two or more operators
  409.    implemented by the same routine.  Some routines do not use the operator
  410.    number.  Formatting of the result of arithmetic operators, including
  411.    rounding to the required precision, is handled by stacknum(). */
  412.  
  413. void binplus(op) /* Implements OPadd - the binary + operator */
  414. char op;
  415. {
  416.    int n1,n2,n3;
  417.    int m1,m2;
  418.    int z1,z2;
  419.    int e1,e2,e3;
  420.    int l1,l2,l3;
  421.    int i;
  422.    int c=0;
  423.    int d1,d2;
  424.    if((n2=num(&m2,&e2,&z2,&l2))<0)die(Enum); /* The two numbers are fetched */
  425.    delete(&l3);                              /* and deleted from the stack  */
  426.    if((n1=num(&m1,&e1,&z1,&l1))<0)die(Enum);
  427.    delete(&l3);
  428.    if(z1&&z2){stack("0",1);return;}
  429.    if(z1){stacknum(workptr+n2,l2,e2,m2);return;}
  430.    if(z2){stacknum(workptr+n1,l1,e1,m1);return;}
  431.    if(e1<e2)n3=n2,n2=n1,n1=n3,n3=m2,m2=m1,m1=n3,
  432.             e3=e2,e2=e1,e1=e3,l3=l2,l2=l1,l1=l3; /* now e1>=e2 always */
  433.    n3=eworkptr+1,e3=e1;                 /* Initialise a third number. */
  434.    if(m1==m2){ /* add two numbers; the sign of the result is m1 */
  435.       l3=(l1>l2+e1-e2)?l1:(l2+e1-e2);
  436.       if(l3>precision+2)l3=precision+2;
  437.       mtest(workptr,worklen,eworkptr+l3+2,l3+256); /* Make space for 3rd num */
  438.       for(i=l3-1;i>=0;i--){
  439.          if(i>=l1)d1=0;
  440.          else d1=workptr[n1+i]-'0';   /* Get each digit from n1 */
  441.          d2=i+e2-e1;                  /* this gives the position of the  */
  442.          if(d2<0||d2>=l2)d2=0;        /* corresponding digit in n2 */
  443.          else d2=workptr[n2+d2]-'0';  /* Get the digit from n2 */
  444.          d2+=d1+c;                    /* add with carry */
  445.          c=d2/10,d2%=10;
  446.          workptr[n3+i]=d2+'0';        /* Store the answer */
  447.       }
  448.       if(c)n3--,workptr[n3]='0'+c,l3++,e3++; /* carry to the left */
  449.    }
  450.    else{ /* subtract the smaller from the larger. The sign of n1-n2 is m1 */
  451.       if(e1==e2){ /* compare to see which is the largest */
  452.          for(i=0;i<l1&&i<l2;i++){
  453.             if(workptr[n1+i]<workptr[n2+i]){ /* swap numbers */
  454.                n3=n2,n2=n1,n1=n3,l3=l2,l2=l1,l1=l3,m1=m2;
  455.                break;
  456.             }
  457.             if(workptr[n1+i]>workptr[n2+i])break; /* order OK */
  458.          }
  459.          if((i==l1&&i==l2)||i>=precision){ /* numbers are equal; return zero */
  460.             stack("0",1);
  461.             return;
  462.          }
  463.          if(i==l1)n3=n2,n2=n1,n1=n3,l3=l2,l2=l1,l1=l3,m1=m2;
  464.             /* n1 is an initial segment of n2; swap since n1<n2 */
  465.       }/* at this point, n1>n2.  Now the subtraction goes exactly like the
  466.           earlier addition. */
  467.       l3=(l1>l2+e1-e2)?l1:(l2+e1-e2);
  468.       if(l3>precision+2)l3=precision+2;
  469.       mtest(workptr,worklen,eworkptr+precision,precision+256);
  470.       n3=eworkptr;
  471.       for(i=l3;i>=0;i--){
  472.          if(i>=l1)d1='0';
  473.          else d1=workptr[n1+i];
  474.          d2=i+e2-e1;
  475.          if(d2<0||d2>=l2)d2='0';
  476.          else d2=workptr[n2+d2];
  477.          d1-=d2+c;
  478.          if(d1<0)d1+=10,c=1;
  479.          else c=0;
  480.          if(i<precision)workptr[n3+i]=d1+'0';
  481.       }
  482.       if(l3>precision)l3=precision;
  483.       while(l3&&workptr[n3]=='0')l3--,n3++,e3--;
  484.    }
  485.    stacknum(workptr+n3,l3,e3,m1);/* After the operation the result is stacked*/
  486. }
  487.  
  488. void binmin(op) /* OPsub, the binary - operator, is implemented by */
  489. char op;        /* negating and adding. */
  490. {
  491.    unmin(op),
  492.    binplus(op);
  493. }
  494.  
  495. void binmul(op) /* OPmul, the binary * operator */
  496. char op;
  497. {
  498.    int n1,n2,m1,m2,e1,e2,z1,z2,l1,l2;
  499.    int n3,l3;
  500.    int i,j,k;
  501.    int c,d,d1;
  502.    if((n1=num(&m1,&e1,&z1,&l1))<0)die(Enum); /* Get each number and delete */ 
  503.    delete(&l3);                              /* from the stack */
  504.    if((n2=num(&m2,&e2,&z2,&l2))<0)die(Enum);
  505.    delete(&l3);
  506.    if(l1>precision+2)l1=precision+2;
  507.    if(l2>precision+2)l2=precision+2;
  508.    l3=l1+l2;
  509.    if(z1||z2){stack("0",1);return;}          /* zero times x is zero */
  510.    if(l1<l2)i=l2,l2=l1,l1=i,i=n2,n2=n1,n1=i; /* make sure n2 is the shorter */
  511.    mtest(workptr,worklen,eworkptr+l3,l3+256);/* Make room for the answer */
  512.    n3=eworkptr;                              /* this is where it goes */
  513.    for(i=0;i<l3;workptr[n3+(i++)]='0');      /* Initially it is zero */
  514.    for(i=l2-1;i>=0;i--){                     /* Now a long multiplication */
  515.       c=0,
  516.       d1=workptr[n2+i]-'0';
  517.       for(j=l1-1;j>=0;j--){
  518.          k=i+j+1,
  519.          d=(workptr[n1+j]-'0')*d1+c+workptr[n3+k]-'0',
  520.          c=d/10,
  521.          d%=10,
  522.          workptr[n3+k]=d+'0';
  523.       }
  524.       workptr[n3+i]+=c;
  525.    }
  526.    if(abs(e1+=e2+1)+2>maxexp)die(Eoflow);    /* Calculate the exponent */
  527.    for(;l3>0&&workptr[n3]=='0';e1--,n3++,l3--); /* Remove leading zeros */
  528.    stacknum(workptr+n3,l3,e1,m1^m2);         /* Stack the answer */
  529. }
  530.  
  531. void bindiv(op) /* OPdiv,  the binary /  operator;
  532.                    OPidiv, the binary %  operator, and
  533.            OPmod,  the binary // operator  are all handled here */
  534. char op;
  535. {
  536.    int n1,n2,m1,m2,e1,e2,z1,z2,l1,l2;
  537.    int n3,l3;
  538.    int i,j;
  539.    int c,d,mul;
  540.    if((n2=num(&m2,&e2,&z2,&l2))<0)die(Enum);
  541.    delete(&l3);
  542.    if((n1=num(&m1,&e1,&z1,&l1))<0)die(Enum);
  543.    delete(&l3);
  544.    if(z2)die(Edivide);           /* anything divided by zero */
  545.    if(z1){stack("0",1);return;}  /* zero divided by anything */
  546.    if(l1>precision+2)l1=precision+2;
  547.    if(l2>precision+2)l2=precision+2;
  548.    l3=precision+2;               /* The number of digits in the quotient */
  549.    if(op!=OPdiv)l3=e1-e2+1;      /* For % and //, the number of digits in
  550.                                     the integer quotient. */
  551.    if(l3<=0){                    /* The integer result is a fraction */
  552.       if(op==OPidiv)stack("0",1);       /* integer quotient is zero */
  553.       else {
  554.          while(l1>0&&workptr[n1+l1-1]=='0')l1--; /* remove trailing zeros */
  555.          stacknum(workptr+n1,l1,e1,m1); /* remainder result is n1 */
  556.       }
  557.       return;
  558.    }
  559.    if(l3>precision+2)l3=precision+2;
  560.    if(op==OPmod&&l3>precision){
  561.       stack("0",1);
  562.       return;/* if l3>precision, return remainder 0 */
  563.    }
  564.    /* Now extend n1 to length l2+l3-1 with zeros */
  565.    mtest(workptr,worklen,eworkptr+l3+l3+l2,l3+l3+l2+256);
  566.    if(l1<l2+l3)n3=eworkptr+l2+l3-l1;
  567.    else n3=eworkptr;
  568.    for(i=l1;i<l2+l3-1;i++)workptr[n1+i]='0';
  569.    for(i=0;i<l3;i++){ /* loop for each digit of result */
  570.       workptr[n3+i]='0'; /* Start each result digit at zero */
  571.       while(1){
  572.          c=0;
  573.          z1=1;
  574.          if(i)d=workptr[n1+i-1]*10+workptr[n1+i]-'0'*11;
  575.             else d=workptr[n1+i]-'0';
  576.          mul=d/(workptr[n2]-'0'+1);/* The next digit can't be lower than this*/
  577.          if(mul==0)mul=1;          /* continue until subtraction fails */
  578.          for(j=l2-1;j>= -i;j--){   /* do a subtraction */
  579.             if(j>=0)d=workptr[n2+j]-'0';
  580.             else d=0;
  581.             d=workptr[n1+i+j]-d*mul-c-'0';
  582.             if(d)z1=0;
  583.             c=0;
  584.             while(d<0)d+=10,c++;
  585.             workptr[n1+i+j]=d+'0';
  586.          }
  587.          if(z1){workptr[n3+i]+=mul;break;}    /* Exactly zero resulted */
  588.          if(!c){workptr[n3+i]+=mul;continue;} /* A positive value resulted */
  589.          c=0;
  590.          for(j=l2-1;j>= -i;j--){          /* add back a failed subtraction */
  591.             if(j>=0)d=workptr[n2+j]-'0';
  592.             else d=0;
  593.             d+=workptr[n1+i+j]+c;
  594.             if(d>'9')d-=10,c=1;
  595.             else c=0;
  596.             workptr[n1+i+j]=d;
  597.          }
  598.          break; /* This result digit is found */
  599.       }
  600.       if(z1&&i>=l1-l2) { /* exact division */
  601.          l3=i+1;
  602.          if(op==OPmod){stack("0",1);return;} /* zero remainder */
  603.          break; /* The entire result is found */
  604.       }
  605.    }/* End of division: the result can be stacked */
  606.    if(op==OPmod){ /* stack the remainder */
  607.       if(l1<l2+l3)l1=l2+l3-1;
  608.       for(;l1&&workptr[n1]=='0';l1--,e1--,n1++);
  609.       for(;l1>0&&workptr[n1+l1-1]=='0';l1--);
  610.       stacknum(workptr+n1,l1,e1,m1);
  611.    }
  612.    else { /* stack the quotient */
  613.       for(;l3>0&&workptr[n3]=='0';e2++,n3++,l3--);
  614.       while(l3>0&&workptr[n3+l3-1]=='0')l3--;
  615.       if(abs(e1-=e2)>maxexp)die(Eoflow);
  616.       stacknum(workptr+n3,l3,e1,m1^m2);
  617.    }
  618. }
  619.  
  620. void binexp(op) /* OPpower, the binary ** operator */
  621. char op;
  622. {
  623.    int pow,n,m,e,z,l,pm=0,c=four*8-1; /* Ahem! 8 bits per byte here */
  624.    char *ptr;
  625.    pow=getint(1);           /* The exponent must be an integer. */
  626.    if(pow<0)pow= -pow,pm=1; /* find x**(abs(y)) first, then calculate x**y */
  627.    if((n=num(&m,&e,&z,&l))<0)die(Enum);  /* A copy of the first operand */
  628.    if(pow==0){
  629.       delete(&l);
  630.       stack("1",1);  /* x ** 0 is 1 */
  631.       return;
  632.    }
  633.    if(z)return;      /* 0 ** x is 0 - note the zero operand is still stacked */
  634.    while(pow>0)pow<<=1,c--;/* Get the MSB of the num into the MSB of the int */
  635.    precision+=2;           /* Temporarily increase precision for good result */
  636.    while((c--)>0){         /* For each bit of the exponent */
  637.       rxdup(),             /* Square the intermediate result */
  638.       binmul(op);
  639.       if((pow<<=1)<0)      /* If the next bit of the exponent is set,        */
  640.          stacknum(workptr+n,l,e,m),binmul(op);  /* multiply the number in    */
  641.    }
  642.    if(pm){ /* The exponent was negative, so invert the number */
  643.       mtest(cstackptr,cstacklen,ecstackptr+2*four,256);
  644.       ptr=cstackptr+ecstackptr-four,
  645.       l= align(*(int *)ptr),
  646.       ptr-=l,   /* ptr points to the stack entry containing the result */
  647.       l+=four,  /* l contains its whole length */
  648.       n=2*four;
  649.       for(c=l-1;c>=0;c--)ptr[c+n]=ptr[c]; /* Make two ints-worth of space */
  650.       ptr[0]='1',
  651.       *(int *)(ptr+four)=1, /* Store the stack entry "1" in the space */
  652.       ecstackptr+=n,
  653.       bindiv(2);            /* Now divide 1 by the result. */
  654.    }
  655.    precision-=2;            /* Restore the old precision */
  656.    n=num(&m,&e,&z,&l),      /* Prepare to reformat the number to the new */
  657.    delete(&c),              /* precision by unstacking and restacking */
  658.    eworkptr=0;
  659.    while(l>0&&workptr[n+l-1]=='0')l--;  /* first remove trailing zeros */
  660.    stacknum(workptr+n,l,e,m);
  661. }
  662.  
  663. void rxdup() /* Duplicate the top stack entry */
  664. {
  665.    char *mtest_old;
  666.    long mtest_diff;
  667.    char *ptr=cstackptr+ecstackptr;
  668.    int len= align(*((int *)ptr-1))+four;
  669.    if dtest(cstackptr,cstacklen,ecstackptr+len,len+256)
  670.       ptr+=mtest_diff;
  671.    memcpy(ptr,ptr-len,len), /* Simple, really... */
  672.    ecstackptr+=len;
  673. }
  674.  
  675. void binrel(op) /* Implements all the comparison operators. */
  676. char op;
  677. {
  678.    int len1,len2;
  679.    int i;
  680.    int ans=0;
  681.    unsigned char *ptr1,*ptr2;
  682.    int n,m,e1,e2,z,l;
  683.    n=num(&m,&e2,&z,&l),  /* Test to see whether the top value is a number */
  684.    ptr2=(unsigned char *)delete(&len2), /* Delete the top value */
  685.    n=(n<0||num(&m,&e1,&z,&l)<0);  /* Test to see whether both are numbers */
  686.    if(op==OPeequ||op>=OPnneq){    /* The strict comparison operators */
  687.       ptr1=(unsigned char *)delete(&len1);
  688.    /* Now see which one is greater, before calculating the required result */
  689.       if(op>OPnneq||len1==len2){
  690.          for(i=0;i<len1&&i<len2&&ptr1[i]==ptr2[i];i++);
  691.          if(i==len1)ans= -!(i==len2); /* string1 is a prefix of string2 */
  692.          else if(i==len2)ans=1;       /* string2 is a prefix of string1 */
  693.          else ans=ptr1[i]-ptr2[i];    /* strings differ at this character */
  694.       }
  695.       else ans=1; /* for == and \== with lengths different, report not equal */
  696.       switch(op){
  697.          case OPeequ: ans=!ans;    break;
  698.          case OPnneq: ans=(ans!=0);break;
  699.          case OPlless:ans=(ans<0); break;
  700.          case OPggrtr:ans=(ans>0); break;
  701.          case OPlleq: ans=(ans<=0);break;
  702.          case OPggeq: ans=(ans>=0);
  703.       }
  704.    }
  705.    else {
  706.       ecstackptr+=align(len2)+four;   /* restack string2 */
  707.       if(!n){                         /* both numeric */
  708.          i=precision,precision=fuzz,  /* add fuzz */
  709.          binmin(op),                  /* compare using binary - */
  710.          precision=i,
  711.          n=num(&m,&i,&z,&l),          /* get flags, then discard the result */
  712.          delete(&l);
  713.       }
  714.       else { /* string comparison; first strip spaces */
  715.          strip(),
  716.          ptr2=(unsigned char *)delete(&len2), /* Get pointers and lengths of */
  717.          strip(),                             /* the stripped strings and    */
  718.          ptr1=(unsigned char *)delete(&len1); /* delete them from the stack. */
  719.          for(i=0;i<len1&&i<len2&&ptr1[i]==ptr2[i];i++); /* Compare */
  720.          if(i==len1)while(i<len2&&ptr2[i]==' ')i++; /* Act as if the shorter */
  721.          if(i==len2)while(i<len1&&ptr1[i]==' ')i++; /* were padded wth spaces*/
  722.          if(i>=len1)           /* now set flags as for numeric comp. */
  723.             if(i>=len2)z=1,m=0;
  724.             else z=0,m=(ptr2[i]>' ');
  725.          else if(i>=len2)z=0,m=(ptr1[i]<' ');
  726.          else z=0,m=(ptr1[i]<ptr2[i]);
  727.       }
  728.       if(z){if(op==OPequ||op==OPleq||op==OPgeq)ans=1;} /* This gives the     */
  729.       else if(op==OPgrtr&&!m || op==OPneq)ans=1;       /* correct result for */
  730.       if(m){if(op==OPless||op==OPleq)ans=1;}           /* the required op    */
  731.       else if(op==OPgeq)ans=1;
  732.    }
  733.    ptr1=(unsigned char *)(cstackptr+ecstackptr), /* The result is stacked */
  734.    ecstackptr+=2*four,
  735.    (*ptr1)='0'+ans,
  736.    (*(int *)(ptr1+four))=1;
  737. }
  738. void binbool(op)  /* OPand, OPxor, OPor - binary &, |, && operators */
  739. char op;
  740. {
  741.    int z1;
  742.    int minus,exp,zero,len;
  743.    if(num(&minus,&exp,&z1,&len)<0)die(Enum);  /* Get the two numbers and */
  744.    delete(&len);                              /* delete the second */
  745.    if(num(&minus,&exp,&zero,&len)<0)die(Enum);
  746.    switch(op){
  747.       case OPand:if(z1)delete(&len),stack("0",1);
  748.          break;
  749.       case OPxor:if(!z1)unnot(op);
  750.          break;
  751.       case OPor:if(!z1)delete(&len),stack("1",1);
  752.    }
  753. }
  754. void bincat(op) /* OPcat, OPspc - concatenation without/with a space */
  755. char op;
  756. {
  757.    int len1,len2,alen1,alen2;
  758.    char *ptr=cstackptr+ecstackptr-four;
  759.    char *aptr;
  760.    alen1=align(len1= *(int *)ptr),
  761.    alen2=align(len2= *((int*)(ptr-alen1)-1));
  762.    aptr=ptr-(alen1+four+alen2-len2);
  763.    if(op==OPspc)*(aptr++)=' ',len1++;
  764.    memcpy(aptr,ptr-alen1,len1);
  765.    ecstackptr+=align(len1+len2)-alen1-alen2-four,
  766.    (*((int *)(cstackptr+ecstackptr)-1))=len1+len2;
  767. }
  768.  
  769. void unnot(op) /* OPnot, unary \ operator */
  770. char op;
  771. {
  772.    int minus,exp,zero,len;
  773.    if(num(&minus,&exp,&zero,&len)<0)die(Enum);
  774.    delete(&len);
  775.    if(zero)stack("1",1);
  776.    else stack("0",1);
  777. }
  778. void unmin(op) /* OPneg, unary - */
  779. char op;
  780. {
  781.    int a,b;
  782.    int minus,exp,zero,len;
  783.    if((a=num(&minus,&exp,&zero,&len))<0)die(Enum);
  784.    delete(&b);
  785.    if(zero)stack("0",1);
  786.    else stacknum(workptr+a,len,exp,!minus); /* restack with opposite sign */
  787. }
  788. void unplus(op) /* OPplus, unary +  -just unstack and restack, thus checking */
  789. char op;       /*                  that it is numeric and reformatting it   */
  790. {
  791.    int a,b;
  792.    int minus,exp,zero,len;
  793.    if((a=num(&minus,&exp,&zero,&len))<0)die(Enum);
  794.    delete(&b);
  795.    if(zero)stack("0",1);
  796.    else stacknum(workptr+a,len,exp,minus);
  797. }
  798.  
  799. void strip() /* Strip leading and trailing spaces from the top stack value */
  800. {
  801.    char *ptr=cstackptr+ecstackptr-four;
  802.    char *ptr1;
  803.    int len= *(int *)ptr;
  804.    int i;
  805.    ptr-=align(len),        /* Point to the value */
  806.    ptr1=ptr,               /* save the original pointer */
  807.    ecstackptr-=align(len); /* discount the original length */
  808.    for(;len>0&&ptr[0]==' ';len--,ptr++);  /* Skip leading spaces */
  809.    for(;len>0&&ptr[len-1]==' ';len--);    /* Remove trailing spaces */
  810.    if(ptr==ptr1)ptr1+=len;  /* If no leading spaces leave the value in place */
  811.    else for(i=0;i<len;i++,(*(ptr1++))=(*(ptr++)));   /* else move it back */
  812.    (*(int *)(ptr1+toalign(len)))=len,
  813.    ecstackptr+=align(len);
  814. }
  815.  
  816. int num(minus,exp,zero,len)
  817. int *minus,*exp,*zero,*len;
  818. { /* examines the `last value' on the calculator stack to determine whether
  819.      it is numeric (always leaves the number stacked). If not, then the answer
  820.      is -1, otherwise the answer is an offset within the workspace where a
  821.      sequence of digits is to be found. In this case, the sequence of digits,
  822.      when a decimal point is added between the 1st and 2nd digits and the
  823.      result is multiplied by 10**exp, is equal to the magnitude of the number.
  824.      `minus' is 1 if the number is negative; `zero' is 1 if the number is zero,
  825.      and `len' is the length of the sequence of digits. */
  826.    register char *ptr1=cstackptr+ecstackptr-four;
  827.    register int ptr2=eworkptr;
  828.    int ans=ptr2;
  829.    register int len1= *(int *)ptr1;
  830.    int dot=0;
  831.    int etmp,emin;
  832.    register int myzero=1; /* fast-access copy of "*zero" */
  833.    register int myexp=-1; /* and of *exp */
  834.    register int ch;
  835.    if(len1<0)die(Ecall); /* doing any numeric operation whatsoever on a 'null'
  836.                          is strictly forbidden! */
  837.    ptr1-=align(len1);    /* ptr1 points to the value, len1 holds its length */
  838.    mtest(workptr,worklen,ptr2+len1,len1+256);
  839.    (*minus)=0;           /* Assume positive; set negative if '-' found */
  840.    for(;ptr1[0]==' '&&len1>0;len1--,ptr1++); /* Skip leading spaces */
  841.    for(;len1>0&&ptr1[len1-1]==' ';len1--);   /* and trailing spaces */
  842.    if((ch=ptr1[0])=='-')ptr1++,len1--,(*minus)=1; /* Deal with leading sign */
  843.    else if(ch=='+')ptr1++,len1--;
  844.    for(;ptr1[0]==' '&&len1>0;len1--,ptr1++); /* and spaces after it */
  845.    if(len1<=0||(ch=ptr1[0])>'9'||ch=='.'&&(len1==1||ptr1[1]>'9'))
  846.       return -1;  /* initial check for validity */
  847.    for(;len1>0;ptr1++,len1--){ /* Now, examine each character of the number */
  848.       if((ch=ptr1[0])=='0'&&myzero){
  849.          if(dot)myexp--;       /* Each leading 0 after the dot divides by 10 */
  850.      continue;
  851.       }
  852.       if(ch>='0'&&ch<='9'){
  853.          myzero=0;  /* Either zero was false already, or a non-zero digit was
  854.                    found. */
  855.          if(!dot)myexp++;  /* Each figure before the dot multiplies by 10 */
  856.          workptr[ptr2++]=ch;
  857.       }
  858.       else if(ch=='.'){
  859.          if(dot)return -1;     /* Count the number of dots */
  860.          dot=1;
  861.       }
  862.       else if((ch&0xdf)=='E'){ /* Now deal with an exponent */
  863.          ptr1++,len1--;
  864.      emin=etmp=0;
  865.          if((ch=ptr1[0])=='-')emin=1,ptr1++,len1--;
  866.          else if(ch=='+')ptr1++,len1--;
  867.          if(len1<=0)return -1;
  868.          for(;len1>0;ptr1++,len1--){
  869.             if((ch=ptr1[0]-'0')<0||ch>9)return -1; /* Must contain digits */
  870.             etmp=etmp*10+ch;
  871.             if(etmp>maxexp)die(Eoflow);
  872.          }
  873.      *len=ptr2-ans;
  874.      eworkptr=ptr2;
  875.          if(*zero=myzero) return *exp=*minus=0,ans; /* No exponent if zero */
  876.          if(emin)etmp= -etmp;    /* Otherwise set the exponent and return. */
  877.          (*exp)=myexp+etmp;
  878.          return ans;
  879.       }
  880.       else return -1; /* Each character must be a digit or "E" or "." */
  881.    }
  882.    *len=ptr2-ans;
  883.    if(*zero=myzero) *exp=*minus=0; /* no exponent or sign if zero */
  884.    else *exp=myexp;
  885.    eworkptr=ptr2;  /* Protect this number from being overwritten, */
  886.    return ans;     /* and return it. */
  887. }
  888.  
  889. int getint(flg)
  890. int flg;
  891. { /* get an integer from the calculator stack. Error if overflow.
  892.      if flg=1 and the number was non-integral an error is raised */
  893.    int n,minus,exp,zero,len,d;
  894.    unsigned ans=0;
  895.    if((n=num(&minus,&exp,&zero,&len))<0)die(Enum); /* First get the number  */
  896.    delete(&d);                                     /* and delete it         */
  897.    if(zero)return 0;
  898.    for(;len>0&&workptr[n+len-1]=='0';len--);       /* remove trailing zeros */
  899.    if(flg&&len>exp+1)die(Enonint);                 /* not an integer        */
  900.    for(;len>0&&exp>=0;exp--,len--,n++){       /* now collect all the digits */
  901.       ans=ans*10+workptr[n]-'0';
  902.       if((int)ans<0)die(Erange);
  903.    }                                       /* Take account of the exponent. */
  904.    for(;exp>=0;exp--,ans*=10)if((int)ans<0)die(Erange);
  905.    if(minus)ans= -ans;               /* and finally, give the correct sign. */
  906.    return ans;
  907. }
  908.  
  909. int isint(num,len,exp) /* Given components of a number obtained by num(), */
  910. int num,len,exp;       /* tell whether it represents an integer.          */
  911. {
  912.    for(;len>0&&workptr[num+len-1]=='0';len--);
  913.    return len<=exp+1&&exp<precision&&(exp<9||exp==9&&workptr[num]<'2');
  914. }
  915.  
  916. char *delete(len)  /* Delete an item from the calculator stack, returning */
  917. int *len;          /* its position and setting "len" to its length.  The  */
  918. {                  /* item is not actually deleted from memory, so it can */
  919.                    /* still be examined, but it will probably soon be     */
  920.            /* overwritten by new values on the stack.             */
  921.    char *ptr=cstackptr+ecstackptr-four;
  922.    (*len)= *(int *)ptr;
  923.    if(*len>=0)ptr-= align(*len),
  924.               ecstackptr-= align(*len);
  925.    else ptr=(char *)-1;     /* I don't think this value is ever used */
  926.    ecstackptr-=four;
  927.    return ptr;
  928. }
  929.  
  930. int isnull() /* Tell whether the top value on the stack is null, i.e. */
  931. {            /* has length = -1                                       */
  932.    char *ptr=cstackptr+ecstackptr-four;
  933.    return (*(int *)ptr)<0;
  934. }
  935.  
  936. void stacknum(num,len,exp,minus)
  937. char *num;
  938. int exp,len,minus;
  939. { /* stack the number given by sequence of digits `num' of length `len' 
  940.      and exponent `exp'. minus=0 if the number is positive, 1 if negative. */
  941.    char *ptr1;
  942.    int len1=0;
  943.    int i;
  944.    mtest(cstackptr,cstacklen,ecstackptr+len+30,len+256);
  945.    ptr1=cstackptr+ecstackptr;
  946.    if(len<=0)num="0",len=1,exp=0,minus=0;
  947.    if(len>precision)   /* Round to the correct number of digits */
  948.       if(num[len=precision]>='5'){
  949.          for(i=len-1;i>=0;i--){
  950.             if(++num[i]<='9')break;
  951.             num[i]='0';
  952.          }
  953.          if(i<0){      /* change 999995 to 10000E+1 (or whatever) */
  954.             for(i=len-2;i>=0;i--)num[i+1]=num[i];
  955.             num[0]='1',
  956.             exp++;
  957.          }
  958.       }  /* Now stack the digits, starting with a sign if negative */
  959.    if(minus)ptr1[len1++]='-';
  960.    if(len-exp-1<=2*precision&&exp<precision){ /* stack with no exponent */
  961.       if(exp<0){                       /* begin with 0.00...0    */
  962.          ptr1[len1++]='0',
  963.          ptr1[len1++]='.';
  964.          for(i= -1;i>exp;i--)ptr1[len1++]='0';
  965.       }
  966.       while(len>0){                    /* stack the digits */
  967.          ptr1[len1++]=num[0],
  968.          num++,
  969.          len--,
  970.          exp--;
  971.          if(len&&exp==-1)ptr1[len1++]='.'; /* remembering the decimal point  */
  972.       }
  973.       while(exp>-1)ptr1[len1++]='0',exp--; /* Add zeros up to the decimal pt */
  974.    }
  975.    else{       /* stack floating point in appropriate form with exponent */
  976.       ptr1[len1++]=num++[0],len--;   /* The (first) digit before the "." */
  977.       if(numform)while(exp%3)        /* For engineering, up to two more  */
  978.             exp--,                   /* digits are required before "."   */
  979.             ptr1[len1++]=(len-->0 ? (num++)[0] : '0');
  980.       if(len>0){                     /* Now the "." and the rest of the  */
  981.          ptr1[len1++]='.';           /* digits.                          */
  982.          while(len--)ptr1[len1++]=(num++)[0];
  983.       }
  984.       if(exp){                       /* Add the exponent                 */
  985.          ptr1[len1++]='E',
  986.          ptr1[len1++]= exp<0 ? '-' : '+',
  987.          exp=abs(exp);
  988.      if(exp>maxexp)die(Eoflow);
  989.          for(i=1;i<=exp;i*=10);
  990.          i/=10;
  991.          for(;i>=1;i/=10)
  992.             ptr1[len1++]=exp/i+'0',
  993.             exp%=i;
  994.       }
  995.    }
  996.    *(int *)(ptr1+align(len1))=len1; /* Finish off the stack entry.       */
  997.    ecstackptr+=align(len1)+four;
  998. }
  999.  
  1000. void getvarname(line,ptr,varname,namelen,maxlen) /* Go along a program line,
  1001.                          accumulating characters to form a variable name.  If
  1002.              it is a compound symbol, the substitution in the tail
  1003.              is performed here also.  If the character pointer
  1004.              does not point to a valid symbol, then on exit
  1005.              varname[0]=namelen=0. */
  1006. char *line;     /* the program line */
  1007. int *ptr;       /* the current character pointer */
  1008. char *varname;  /* where to put the variable name */
  1009. int *namelen;   /* the length of the returned variable name */
  1010. int maxlen;     /* the amount of space allocated to varname */
  1011. {
  1012.    char *exp,*exp1,*vg;
  1013.    char c;
  1014.    int expn;
  1015.    int explen;
  1016.    int disp=trcflag&Tintermed; /* whether to trace compound symbols */
  1017.    char quote;
  1018.    maxlen-=2;                  /* a safety margin :-) */
  1019.    if(rexxsymbol(line[*ptr])<1) /* Test the starting character */
  1020.       {varname[0]=0;(*namelen)=0;return;}
  1021.    for(exp=varname;rexxsymbol(line[*ptr]);exp++,(*ptr)++){
  1022.       if(exp-varname>maxlen)die(Elong);  /* Copy the stem or simple symbol */
  1023.       (*exp)=line[*ptr];
  1024.    }
  1025.    if(line[*ptr]=='.'){
  1026.       varname[0]|=128;                   /* flag: not a simple symbol */
  1027.       if((c=line[*ptr+1])<=' '||!(rexxsymboldot(c)||c=='('||c=='\''||c=='\"'))
  1028.          (*ptr)++;                       /* stem - step past the final dot */
  1029.       else disp|=4;                      /* compound symbol (so display it) */
  1030.    }
  1031.    while(line[*ptr]=='.'){/* Loop to interpret the qualifiers of a comp.symb.*/
  1032.       (*ptr)++,
  1033.       (*(exp++))='.';     /* Step past and copy the dot */
  1034.       if(line[*ptr]<=' ')break; /* Stop if at a space, terminator, or token */
  1035.       switch(line[*ptr]){ /* What kind of qualifier is it? */
  1036.          case '.':break;  /* null qualifier */
  1037.          case '(':(*ptr)++, /* parenthesised expression e.g. stem.(a+b) */
  1038.             exp1=scanning(line,ptr,&explen),  /* Get the expression    */
  1039.             ecstackptr=exp1-cstackptr;        /* delete the expression */
  1040.             if(exp+explen-varname>maxlen)die(Elong);
  1041.             memcpy(exp,exp1,explen),          /* Copy to the varname */
  1042.             exp+=explen;
  1043.             if(line[(*ptr)++]!=')')die(Elpar);/* Expect ')' */
  1044.             break;
  1045.          case '\'': /* Quoted expression e.g. stem.'tail' */
  1046.          case '\"':quote=line[(*ptr)++];
  1047.             for(expn= *ptr;(line[expn++])!=quote;);/*Find the matching quote */
  1048.             if(exp+expn-*ptr-varname>maxlen)die(Elong);
  1049.             memcpy(exp,line+*ptr,expn-*ptr-1),     /* Copy the string */
  1050.             exp+=expn-*ptr-1,
  1051.             (*ptr)=expn;
  1052.             break;
  1053.          default: exp1=exp; /* The usual qualifier - a symbol */
  1054.             while(rexxsymbol(line[*ptr])){  /* append the symbol to the name */
  1055.                if(exp-varname>maxlen)die(Elong);
  1056.                (*(exp++))=line[(*ptr)++];
  1057.             }
  1058.             if(exp1!=exp&&rexxsymbol(exp1[0])==1){/* non-null non-constant */
  1059.                (*exp)=0,
  1060.                vg=varget(exp1,exp-exp1,&explen); /* See if the sym has a val */
  1061.                if(vg!=cnull){                    /* if so, substitute */
  1062.                   exp=exp1;
  1063.                   if(exp+explen-varname>maxlen)die(Elong);
  1064.                   memcpy(exp,vg,explen),
  1065.                   exp+=explen;
  1066.                }
  1067.             }
  1068.       }
  1069.    }
  1070.    if(disp==12)                            /* tracing compound symbols */
  1071.       traceline(">C>",varname,exp-varname);
  1072.    (*exp)=0,
  1073.    (*namelen)=exp-varname;
  1074. }
  1075.  
  1076. void skipvarname(line,ptr) /* Skip a variable name in a program line */
  1077.                            /* It is guaranteed to start with a valid char */
  1078. char *line;                /* the program line */
  1079. int *ptr;                  /* the current character pointer */
  1080. {
  1081.    char *exp;
  1082.    char quote;
  1083.    int paren;
  1084.    while(rexxsymbol(line[*ptr])) (*ptr)++;
  1085.    while(line[*ptr]=='.'){/* Loop to skip the qualifiers of a compound symbol*/
  1086.       (*ptr)++;           /* step past the dot */
  1087.       if(line[*ptr]<=' ')break; /* Stop if at a space, terminator, or token */
  1088.       switch(line[*ptr]){ /* What kind of qualifier is it? */
  1089.          case '.':break;  /* null qualifier */
  1090.          case '(':(*ptr)++; /* parenthesised expression e.g. stem.(a+b) */
  1091.             for(paren=1;paren&&line[*ptr]&&line[*ptr]!=-1;(*ptr)++)
  1092.            if(line[*ptr]=='(')paren++;       /* Find matching ')' */
  1093.            else if(line[*ptr]==')')paren--;
  1094.         if(paren)die(Elpar);
  1095.             break;
  1096.          case '\'': /* Quoted expression e.g. stem.'tail' */
  1097.          case '\"':quote=line[(*ptr)++];
  1098.             while((line[(*ptr)++])!=quote); /* Find the matching quote */
  1099.             break;
  1100.          default: /* The usual qualifier - a symbol */
  1101.             while(rexxsymbol(line[*ptr]))(*ptr)++;
  1102.       }
  1103.    }
  1104. }
  1105.  
  1106. int gettoken(line,ptr,varname,maxlen,ex) /* Go along a program line and form
  1107.     a token, i.e. a sequence of characters which are valid in symbols - such
  1108.     as the word coming after SIGNAL. The token may be quoted, in which case
  1109.     the return value is 2, or a symbol, in which case 1 is returned.  If ex
  1110.     is non-zero and the token is obviously not a symbol or a quoted string,
  1111.     then it may be an entire expression, perhaps preceded by VALUE - as in
  1112.     SIGNAL VALUE x.  In that case 0 is returned.  The token is terminated
  1113.     with a null after it has been collected. */
  1114. char *line;    /* the program line */
  1115. int *ptr;      /* the character pointer */
  1116. char *varname; /* where to put the token */
  1117. int maxlen;    /* the amount of space available in varname */
  1118. int ex;        /* whether or not an entire expression is allowed */
  1119. {
  1120.    char *exp;
  1121.    int i;
  1122.    int explen;
  1123.    char quote;
  1124.    if(rexxsymboldot(line[*ptr])){ /* it's just a simple symbol */
  1125.       for(i=0;rexxsymboldot(line[*ptr]);varname[i++]=line[(*ptr)++])
  1126.          if(i>=maxlen-2)die(Elong);
  1127.       varname[i]=0;
  1128.       return 1;
  1129.    }
  1130.    if((quote=line[(*ptr)++])=='\''||quote=='\"'){ /* it's a string constant */
  1131.       for(i=0;(varname[i++]=line[(*ptr)++])!=quote;) if(i>=maxlen-1)die(Elong);
  1132.       varname[--i]=0;
  1133.       if(!i)die(Enostring);
  1134.       return 2;
  1135.    }
  1136.    if(!ex)die(Enostring);  /* it must be an expression; is that allowed? */
  1137.    if(line[--*ptr]==VALUE)(*ptr)++;  /* VALUE is optional here */
  1138.    if(!line[*ptr])die(Enostring);
  1139.    scanning(line,ptr,&explen);     /* get the expression */
  1140.    exp=delete(&explen);
  1141.    if(explen>maxlen-1)die(Elong);
  1142.    memcpy(varname,exp,explen);     /* and copy it */
  1143.    varname[explen]=0;
  1144.    if(line[*ptr]==')')die(Erpar);  /* save some work by flagging extra ')'s
  1145.                                    now.  This must be the end of a clause. */
  1146.    return 0;
  1147. }
  1148.